home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / coolca1a / cdxvbfon.cls next >
Encoding:
Visual Basic class definition  |  1999-09-16  |  5.6 KB  |  192 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "CDXVBFont"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. ' Not defined right in win32.tlb
  15. Private Declare Function SetTextCharacterExtra Lib "gdi32" Alias "SetTextCharacterExtraA" (ByVal hDC As Long, ByVal nCharExtra As Long) As Long
  16. Private Const VTA_BASELINE = TA_BASELINE
  17. Private Const VTA_BOTTOM = TA_RIGHT
  18. Private Const VTA_CENTER = TA_CENTER
  19. Private Const VTA_LEFT = TA_BOTTOM
  20. Private Const VTA_RIGHT = TA_TOP
  21. Private Const VTA_TOP = TA_LEFT
  22.  
  23. ' Handle to current font
  24. Public m_Font As Long
  25.  
  26. ' Internal data type for RGB and Hex conversions
  27. Private Type RGBLongs
  28.     R As Long
  29.     G As Long
  30.     B As Long
  31. End Type
  32.  
  33. Private m_TextSize As Size
  34.  
  35. ' Used to fill a listbox with all the fonts on the
  36. ' computer, which can then be used with CreateNewFont
  37. ' for maybe a font selector
  38. Public Sub FillListBoxWithFonts(lstbx As ListBox)
  39.     For i = 0 To Screen.FontCount
  40.         lstbx.AddItem Screen.Fonts(i), i
  41.     Next i
  42. End Sub
  43.  
  44. ' Sets intercharacter spacing
  45. Public Sub SetTextSpacing(obj As Object, spacing As Long)
  46.     SetTextCharacterExtra obj.hDC, spacing
  47. End Sub
  48.  
  49. ' Get width of string of text in pixels
  50. Public Function GetTextWidth(obj As Object, txt As String) As Long
  51.     GetTextExtentPoint32 obj.hDC, txt, Len(txt), m_TextSize
  52.     GetTextWidth = m_TextSize.cx
  53. End Function
  54.  
  55. ' Get height of string of text in pixels
  56. Public Function GetTextHeight(obj As Object, txt As String) As Long
  57.     GetTextExtentPoint32 obj.hDC, txt, Len(txt), m_TextSize
  58.     GetTextHeight = m_TextSize.cy
  59. End Function
  60.  
  61. ' Creates a new font according to your specifications
  62. Public Sub CreateNewFont(FontName As String, Optional Width As Integer = 0, Optional Height As Integer = 0, Optional FontWeight As Integer = FW_NORMAL, Optional Italic As Boolean = False, Optional Underline As Boolean = False, Optional Strikeout As Boolean = False)
  63.     DeleteObject m_Font
  64.     m_Font = CreateFont(Height, Width, 0, 0, FontWeight, Italic, Underline, Strikeout, ANSI_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, FontName)
  65.     If m_Font = 0 Then MsgBox "Unable to create font: " & FontName
  66. End Sub
  67.  
  68. ' Sets the objects font to the currently selected one
  69. Public Sub SetFont(hDC As Long)
  70.     SelectObject hDC, m_Font
  71. End Sub
  72.  
  73. Public Sub GradTextOut(obj As Object, X As Integer, Y As Integer, RGBStart As Long, RGBEnd As Long, Text As String)
  74.     Dim rgbls As RGBLongs
  75.     Dim R1 As Long, G1 As Long, B1 As Long, R2 As Long, G2 As Long, B2 As Long
  76.     Dim RI As Long, GI As Long, BI As Long
  77.     Dim RDiff As Integer, GDiff As Integer, BDiff As Integer
  78.     Dim CurR As Integer, CurG As Integer, CurB As Integer
  79.     Dim currenttl As Long
  80.     
  81.     rgbls = RGBConv(RGBStart)
  82.     R1 = rgbls.R
  83.     G1 = rgbls.G
  84.     B1 = rgbls.B
  85.  
  86.     rgbls = RGBConv(RGBEnd)
  87.     R2 = rgbls.R
  88.     G2 = rgbls.G
  89.     B2 = rgbls.B
  90.     
  91.     RDiff = R2 - R1
  92.     RI = RDiff / (Len(Text) - 1)
  93.  
  94.     GDiff = G2 - G1
  95.     GI = GDiff / (Len(Text) - 1)
  96.  
  97.     BDiff = B2 - B1
  98.     BI = BDiff / (Len(Text) - 1)
  99.  
  100.     For i = 0 To (Len(Text) - 1)
  101.         CurR = R1 + (RI * i)
  102.         CurG = G1 + (GI * i)
  103.         CurB = B1 + (BI * i)
  104.  
  105.         If CurR < 0 Then CurR = 0
  106.         If CurG < 0 Then CurG = 0
  107.         If CurB < 0 Then CurB = 0
  108.  
  109.         obj.ForeColor = RGB(CurR, CurG, CurB)
  110.         
  111.         currenttl = currenttl + GetTextWidth(obj, Mid(Text, i + 1, 1))
  112.  
  113.         TextOut obj.hDC, X + (currenttl) - GetTextWidth(obj, Mid(Text, 1, 1)), Y, Mid(Text, i + 1, 1), 1
  114.     Next i
  115. End Sub
  116.  
  117. ' Center aligns text on the screen when you use TextOut
  118. Public Sub CenterAlignText(obj As Object)
  119.     SetTextAlign obj.hDC, TA_CENTER Or VTA_CENTER
  120. End Sub
  121.  
  122. ' Make background behind text transparent
  123. Public Sub SetTextBackTrans(obj As Object)
  124.     SetBkMode obj.hDC, TRANSPARENT
  125. End Sub
  126.  
  127. ' Set background colour
  128. Public Sub SetTextBackColour(obj As Object, RGBcolor As Long)
  129.     SetBkMode obj.hDC, OPAQUE
  130.     SetBkColor obj.hDC, RGBcolor
  131. End Sub
  132.  
  133. ' Converts RGB to its seperate components
  134. Private Function RGBConv(RGBC As Long) As RGBLongs
  135.     Dim hRGB As String
  136.     Dim rgbl As RGBLongs
  137.     
  138.     hRGB = Hex(RGBC)
  139.     
  140.     Select Case Len(hRGB)
  141.         Case 5:
  142.             hRGB = "0" & hRGB
  143.         Case 4:
  144.             hRGB = "00" & hRGB
  145.         Case 3:
  146.             hRGB = "000" & hRGB
  147.         Case 2:
  148.             hRGB = "0000" & hRGB
  149.         Case 1:
  150.             hRGB = "00000" & hRGB
  151.     End Select
  152.     
  153.     RGBConv = HexToRGB(hRGB)
  154. End Function
  155.  
  156. Private Function HexToRGB(H As String) As RGBLongs
  157.     Dim Tmp$
  158.     Dim R As Integer, B As Integer
  159.     Dim G As Long
  160.     Dim tmprgbl As RGBLongs
  161.     
  162.     Const Hx = "&H"
  163.     Const BigShift = 65536
  164.     Const LilShift = 256, Two = 2
  165.     
  166.     Tmp = H
  167.     
  168.     If UCase(Left$(H, 2)) = "&H" Then Tmp = Mid$(H, 3)
  169.     
  170.     Tmp = Right$("0000000" & Tmp, 8)
  171.     
  172.     If IsNumeric(Hx & Tmp) Then
  173.         R = CInt(Hx & Right$(Tmp, Two))
  174.         G = CLng(Hx & Mid$(Tmp, 5, Two))
  175.         B = CInt(Hx & Mid$(Tmp, 3, Two))
  176.     End If
  177.     
  178.     tmprgbl.R = R
  179.     tmprgbl.G = G
  180.     tmprgbl.B = B
  181.     
  182.     HexToRGB = tmprgbl
  183. End Function
  184.  
  185. Private Sub Class_Initialize()
  186.     m_Font = CreateFont(0, 0, 0, 0, FW_NORMAL, False, False, False, ANSI_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, "COMIC SANS MS")
  187. End Sub
  188.  
  189. Private Sub Class_Terminate()
  190.     DeleteObject m_Font
  191. End Sub
  192.